home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / MISC / MAG08.ZIP / MODE13H.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-04-30  |  7.1 KB  |  327 lines

  1. Unit Mode13h;
  2.  
  3. { Version 1.1 }
  4.  
  5. Interface
  6.  
  7. Const VGA=$A000;
  8.       Npages=3;
  9.  
  10. Type RgbItem=Record
  11.                    R,G,B:Byte;
  12.              End;
  13.      RgbList=Array[0..255] of RgbItem;
  14.      Table=Array[0..1799] Of Real;
  15.      PTable=^Table;
  16.  
  17. Var Sines:Ptable;
  18.     Cosines:Ptable;
  19.     Virt:Array[1..Npages] Of Pointer;
  20.     VP:Array[1..Npages] Of Word;
  21.  
  22. Procedure Initgraph;
  23. Procedure Closegraph;
  24. Procedure PutPixel(X,Y:word;Col:Byte;Where:Word);
  25. Function GetPixel(X,Y:word;Where:Word):Byte;
  26. Procedure Cls(Col:Byte;Where:Word);
  27. Procedure WaitVBL;
  28. Procedure GetColor(Col:Byte;Var R,G,B:Byte);
  29. Procedure SetColor(Col,R,G,B:Byte);
  30. Procedure GetPalette(Var Pal:RgbList);
  31. Procedure SetPalette(Pal:RgbList);
  32. Procedure RotatePal(Var Pal:RgbList;First,Last:Byte);
  33. Procedure Fade(Target:RgbList);
  34. Procedure Circle(X,Y,R:Integer;Col:Byte;Where:Word);
  35. Function Sgn(A:Real):Integer;
  36. Procedure Line(X1,Y1,X2,Y2,Col:Integer;Where:Word);
  37. Procedure InitTables;
  38. Procedure ClearTables;
  39. Procedure InitVirt;
  40. Procedure CloseVirt;
  41. Procedure CopyPage(From,Too:Word);
  42. Procedure LoadPCX(Filename:String;Where:Word);
  43.  
  44. Implementation
  45.  
  46. Procedure Initgraph; Assembler;
  47. Asm
  48.    mov ah,0
  49.    mov al,13h
  50.    int 10h
  51. End;
  52.  
  53. Procedure Closegraph; Assembler;
  54. Asm
  55.    mov ah,0
  56.    mov al,03h
  57.    int 10h
  58. End;
  59.  
  60. Procedure PutPixel(X,Y:word;Col:Byte;Where:Word);
  61. Begin
  62.      Mem[Where:(y*320)+x]:=Col;
  63. End;
  64.  
  65. Function GetPixel(X,Y:word;Where:Word):Byte;
  66. Begin
  67.      GetPixel:=Mem[Where:(y*320)+x];
  68. End;
  69.  
  70.  
  71. Procedure Cls(Col:Byte;Where:Word);
  72. Begin
  73.      Fillchar(Mem[Where:0000],64000,Col);
  74. End;
  75.  
  76. Procedure WaitVBL; Assembler;
  77. Label A1,A2;
  78. Asm
  79.    Mov DX,3DAh
  80.    A1:
  81.       In AL,DX
  82.       And AL,08h
  83.       Jnz A1
  84.    A2:
  85.       In AL,DX
  86.       And AL,08h
  87.       Jz A2
  88. End;
  89.  
  90. Procedure GetColor(Col:Byte;Var R,G,B:Byte);
  91. Begin
  92.      Port[$3C7]:=Col;
  93.      R:=Port[$3C9];
  94.      G:=Port[$3C9];
  95.      B:=Port[$3C9];
  96. End;
  97.  
  98. Procedure SetColor(Col,R,G,B:Byte);
  99. Begin
  100.      Port[$3C8]:=Col;
  101.      Port[$3C9]:=R;
  102.      Port[$3C9]:=G;
  103.      Port[$3C9]:=B;
  104. End;
  105.  
  106. Procedure GetPalette(Var Pal:RgbList);
  107. Var A:Byte;
  108. Begin
  109.      For A:=0 To 255 do GetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
  110. End;
  111.  
  112. Procedure SetPalette(Pal:RgbList);
  113. Var A:Byte;
  114. Begin
  115.      WaitVBL;
  116.      For A:=0 To 255 do SetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
  117. End;
  118.  
  119. Procedure RotatePal(Var Pal:RgbList;First,Last:Byte);
  120. Var Temp:RgbItem;
  121.     A:Byte;
  122. Begin
  123.      Temp:=Pal[Last];
  124.      For A:=Last-1 DownTo First Do Pal[A+1]:=Pal[A];
  125.      Pal[First]:=Temp;
  126. End;
  127.  
  128. Procedure Fade(Target:RgbList);
  129. Var Tmp:RgbList;
  130.     Flag:Boolean;
  131.     Loop:Integer;
  132. Begin
  133.      Repeat
  134.            Flag:=True;
  135.            GetPalette(Tmp);
  136.            For Loop:=0 To 255 Do
  137.            Begin
  138.                 If Tmp[Loop].R>Target[Loop].R Then
  139.                 Begin
  140.                      Dec(Tmp[Loop].R);
  141.                      Flag:=False;
  142.                 End;
  143.                 If Tmp[Loop].G>Target[Loop].G Then
  144.                 Begin
  145.                      Dec(Tmp[Loop].G);
  146.                      Flag:=False;
  147.                 End;
  148.                 If Tmp[Loop].B>Target[Loop].B Then
  149.                 Begin
  150.                      Dec(Tmp[Loop].B);
  151.                      Flag:=False;
  152.                 End;
  153.                 If Tmp[Loop].R<Target[Loop].R Then
  154.                 Begin
  155.                      Inc(Tmp[Loop].R);
  156.                      Flag:=False;
  157.                 End;
  158.                 If Tmp[Loop].G<Target[Loop].G Then
  159.                 Begin
  160.                      Inc(Tmp[Loop].G);
  161.                      Flag:=False;
  162.                 End;
  163.                 If Tmp[Loop].B<Target[Loop].B Then
  164.                 Begin
  165.                      Inc(Tmp[Loop].B);
  166.                      Flag:=False;
  167.                 End;
  168.            End;
  169.            SetPalette(Tmp);
  170.      Until Flag;
  171. End;
  172.  
  173. Procedure Circle(X,Y,R:Integer;Col:Byte;Where:Word);
  174. Var Px,Py:Integer;
  175.     Deg:Word;
  176. Begin
  177.      For Deg:=0 to 1799 Do
  178.      Begin
  179.           Px:=Trunc(R*Sines^[Deg]+X);
  180.           Py:=Trunc(R*Cosines^[Deg]+Y);
  181.           PutPixel(Px,Py,Col,Where);
  182.      End;
  183. End;
  184.  
  185. Function Sgn(A:Real):Integer;
  186. Begin
  187.      If A<0 then Sgn:=-1;
  188.      If A=0 then Sgn:=0;
  189.      If A>0 then Sgn:=+1;
  190. End;
  191.  
  192. Procedure Line(X1,Y1,X2,Y2,Col:Integer;Where:Word);
  193. Var Deltax,S,Deltay,Dx1,Dy1,Dx2,Dy2,S1,S2:Real;
  194.     I:Integer;
  195. Begin
  196.      Deltax:=X2-X1;
  197.      Deltay:=Y2-Y1;
  198.      Dx1:=Sgn(Deltax);
  199.      Dy1:=Sgn(Deltay);
  200.      Dx2:=Sgn(Deltax);
  201.      Dy2:= 0;
  202.      S1:=Abs(Deltax);
  203.      S2:=Abs(Deltay);
  204.      If Not (S1>S2) Then
  205.      Begin
  206.           Dx2:=0;
  207.           Dy2:=Sgn(Deltay);
  208.           S1:=Abs(Deltay);
  209.           S2:=Abs(Deltax);
  210.      End;
  211.      S:=Int(S1/2);
  212.      For I:=0 To Round(S1) Do
  213.      Begin
  214.           PutPixel(X1,Y1,Col,Where);
  215.           S:=S+S2;
  216.           If Not (S<S1) Then
  217.           Begin
  218.                S:=S-S1;
  219.                X1:=X1+Round(Dx1);
  220.                Y1:=Y1+Round(Dy1);
  221.           End
  222.           Else
  223.           Begin
  224.                X1:=X1+Round(dx2);
  225.                Y1:=Y1+Round(Dy2);
  226.           End;
  227.      End;
  228. End;
  229.  
  230. Procedure InitTables;
  231. Var A:Word;
  232.     B:Real;
  233. Begin
  234.      Getmem(Sines,Sizeof(Sines^));
  235.      Getmem(Cosines,Sizeof(Cosines^));
  236.      B:=0;
  237.      For A:=0 To 1799 Do
  238.      Begin
  239.           Sines^[A]:=Sin(B);
  240.           Cosines^[A]:=Cos(B);
  241.           B:=B+0.005;
  242.      End;
  243. End;
  244.  
  245. Procedure ClearTables;
  246. Begin
  247.      Freemem(Sines,Sizeof(Sines^));
  248.      Freemem(Cosines,Sizeof(Cosines^));
  249. End;
  250.  
  251. Procedure InitVirt;
  252. Var A:Byte;
  253. Begin
  254.      For A:=1 To Npages Do
  255.      Begin
  256.           GetMem(Virt[A],64000);
  257.           VP[A]:=Seg(Virt[A]^);
  258.      End;
  259. End;
  260.  
  261. Procedure CloseVirt;
  262. Var A:Byte;
  263. Begin
  264.      For A:=1 To Npages Do
  265.      Begin
  266.           Freemem(Virt[A],64000);
  267.           VP[A]:=$A000;
  268.      End;
  269. End;
  270.  
  271. Procedure CopyPage(From,Too:Word);
  272. Begin
  273.      WaitVbl;
  274.      Move(Mem[From:0],Mem[Too:0],64000);
  275. End;
  276.  
  277. Procedure LoadPCX(Filename:String;Where:Word);
  278. Var Fil:File;
  279.     Dx,Dy:Word;
  280.     J,M:Byte;
  281.     Ph:Word;
  282.     Buff:Array[0..127] of byte;
  283.     PCXPal:RgbList;
  284. Begin
  285.      Assign(Fil,Filename);
  286.      Reset(Fil,1);
  287.      Blockread(Fil,Buff,128);
  288.      Dy:=0;
  289.      Repeat
  290.            Dx:=0;
  291.            Repeat
  292.                  BlockRead(Fil,J,1);
  293.                  If J>192 Then
  294.                  Begin
  295.                       BlockRead(Fil,M,1);
  296.                       Dec(J,192);
  297.                       For Ph:=1 To J Do
  298.                       Begin
  299.                            PutPixel(Dx,Dy,M,Where);
  300.                            Inc(Dx);
  301.                       End;
  302.                  End
  303.                  Else
  304.                  Begin
  305.                       PutPixel(Dx,Dy,J,Where);
  306.                       Inc(Dx);
  307.                  End;
  308.            Until Dx>=320;
  309.            Inc(Dy);
  310.      Until Dy=200;
  311.      BlockRead(Fil,M,1);
  312.      If M=12 Then
  313.      Begin
  314.           BlockRead(Fil,PCXPal,768);
  315.           For M:=0 To 255 Do
  316.           Begin
  317.                PCXPal[M].R:=PCXPal[M].R Div 4;
  318.                PCXPal[M].G:=PCXPal[M].G Div 4;
  319.                PCXPal[M].B:=PCXPal[M].B Div 4;
  320.           End;
  321.           SetPalette(PCXPal);
  322.      End;
  323.      Close(Fil);
  324. End;
  325.  
  326. Begin
  327. End.